-- | A `Vty` frontend of the game.
module Game.Trubis.Vty (main) where

import Graphics.Vty
import Graphics.Vty.AlignMiddle
import Game.Trubis
import Control.Exception
import Control.Concurrent.STM
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.Fix
import Control.Lens
import Data.Text qualified as T
import Data.Array.IArray
import Data.Bifunctor
import Data.Maybe
import Data.Map.Strict qualified as M
import Data.List
import Data.Char
import Data.IORef

main random = do
  -- Initialize
  vty <- mkVty =<< standardIOConfig
  let ?vty = vty
  flip finally (shutdown vty) do
    -- Handle Ctrl-C
    events <- atomically newTQueue
    let ?events = events
    race_
      (fix \continue -> nextEvent vty >>= \case
        EvKey (KChar 'c') [MCtrl] -> return ()
        e -> atomically (writeTQueue events e) >> continue
      )
      do
        -- Intro 
        (keyMap, startLevel) <- intro
        let ?keyMap = keyMap
        -- Game
        (field, stats) <- game
          random
          GameConfig {..}
          {- NOTE: Record wildcards do not work here. -}
          InputEvents
          { nextInputEvent = nextInputEvent'
          , flushInputEvents = flushInputEvents'
          }
          Render
          { render = render'
          , highlightPipe = highlightPipe'
          }
        -- Outro
        updateMiddle ?vty $ layout (toACArray field) stats Nothing True
        waitFor KEnter

-- * Intro

type KeyMap = M.Map Key (InputEvent)

intro :: (?vty :: Vty, ?events :: TQueue Event) => IO (KeyMap, Word)
intro = do
  keys <- newIORef [KLeft, KRight, KDown, KUp]
  startLevel <- newIORef 1
  fix \loop -> do
    updateMiddle ?vty =<< (layout <$> readIORef keys <*> readIORef startLevel)
    waitForAnyKey >>= \case
      KEnter -> return ()
      KChar 'd' -> do
        writeIORef keys =<<
          forM ["LEFT", "RIGHT", "DROP", "ROTATE"] \label -> do
            updateMiddle ?vty $ picForImage $ string defAttr label
            waitForAnyKey
        loop
      k -> do
        let dir = case k of
              KUp -> succ
              KDown -> pred
              _ -> id
        modifyIORef startLevel ((cap levelRange) . dir) >> loop
  keyMap <-
    M.fromList . flip zip [Move (V2 (0-1) 0), Move (V2 1 0), Drop, Rotate]
    <$> readIORef keys
  return =<< ((keyMap,) <$> readIORef startLevel)
 where
  layout keys startLevel = picForImage $
    vertCatMiddle
    [ multiLineText defAttr $ "\
      \╺══╦══╸╔═══╗ ╻   ╻ ╔══╗ ╺═╦═╸╔═══╸  \n\
      \   ║   ║   ║ ║   ║ ║  ║   ║  ║      \n\
      \   ║   ╠══╦╝ ║   ║ ╠══╩╗  ║  ╚═══╗  \n\
      \   ║   ║  ╚╗ ║   ║ ║   ║  ║      ║  \n\
      \   ╹   ╹   ╹ ╚═══╝ ╚═══╝╺═╩═╸╺═══╝  "
    , space
    , string defAttr "ENTER - START GAME"
    , space
    , string defAttr "D - DEFINE KEYS"
    , space
    , string defAttr $ "↑↓ - LEVEL: " ++ show startLevel
    , space
    , string defAttr $ "KEYS: " ++ (intercalate "," $ map display keys)
    , space
    , string defAttr $ "EXIT: CTRL-C"
    ]
   where
    display = \case
      KChar ' ' -> "SPACE"
      KChar c -> toUpper c : []
      KUp -> "↑"
      KDown -> "↓"
      KLeft -> "←"
      KRight -> "→"
      _ -> "?"
  cap (xMin, xMax) = max xMin . min xMax
  levelRange = (1, 10)

-- * `game` requirements

nextInputEvent'
  :: (?events :: TQueue Event, ?keyMap :: KeyMap)
  => STM InputEvent
nextInputEvent' = fix \redo -> readTQueue ?events >>= \case
  EvKey k [] -> fromMaybe (redo) (return <$> ?keyMap M.!? k)
  _ -> redo

flushInputEvents' :: (?events :: TQueue Event) => STM ()
flushInputEvents' = void $ flushTQueue ?events

render' (field, stats) (item, pos) = do
  let field' = (field & toACArray)
        // [(fallPos field pos, itemImage & first ((`withForeColor` magenta) . (`withStyle` dim)))]
        // [(pos, itemImage)]
  updateMiddle ?vty $ layout field' stats Nothing False
 where
  itemImage = case item of
    Bomb -> (defAttr `withForeColor` red `withStyle` bold, 'ó')
    (P s) -> (defAttr, charFor s)

highlightPipe' (field, stats) (item, pos) (pipe, reward) = do
  let field' = field
        & toACArray
        & (// (for (toList pipe) $ second $ \section -> (attr, charFor section)))
        & ifBomb item (// [(pos, explosion)])
  updateMiddle ?vty $ layout field' stats reward' False
 where
  reward' = if reward /= 0 then Just reward else Nothing
  attr = defAttr
    & ifBomb item (`withForeColor` red)
    & (`withStyle` reverseVideo)
  explosion = (defAttr `withForeColor` red `withStyle` reverseVideo, '*')

-- * Game UI

layout field stats reward showOutro =
  emptyPicture
  { picBackground = Background ' ' defAttr
  , picLayers =
      let [fieldPart', outroPart'] = alignMiddle byBoth [fieldPart, outroPart] in
      [ if showOutro then outroPart' else emptyImage
      , horizCatMiddle [ fieldPart', translateX 1 ( statsPart
                                                    <->
                                                    rewardPart ) ]
      ]
  }
 where
  fieldPart =
    (verticalBorder <|> fieldImage <|> verticalBorder)
    <->
    horizontalBorder
   where
    fieldImage =
      vertCat $ for (reverse $ range (fieldMin^._y, fieldMax^._y)) \y ->
        horizCat $ for (range (fieldMin^._x, fieldMax^._x)) \x ->
          uncurry char $ field ! (V2 x y)
    verticalBorder = charFill defAttr '▒' 1 (imageHeight fieldImage)
    horizontalBorder = charFill defAttr '▒' (imageWidth fieldImage + 2) 1
    (fieldMin, fieldMax) = bounds field
  statsPart =
    string defAttr "LEVEL"
    <->
    string defAttr (show $ level stats)
    <-> space <->
    (resizeWidth 10 $ string defAttr "SCORE")
    <->
    string defAttr (show $ score stats)
  rewardPart =
    resizeHeight 1 $ fromMaybe emptyImage do
      reward <- reward
      return $ string (defAttr `withForeColor` green) ('+':show (reward :: Points))

toACArray :: Field -> Array Position (Attr, Char)
toACArray = amap \case
  Nothing -> (defAttr `withForeColor` blue `withStyle` dim, '□')
  Just s -> (defAttr, charFor s)

charFor pipeSection = case outputDirectionBits pipeSection of
  0b0001 -> '╺'; 0b0010 -> '╹'; 0b0100 -> '╸'; 0b1000 -> '╻';
  0b0101 -> '═'; 0b1010 -> '║';
  0b0011 -> '╚'; 0b0110 -> '╝'; 0b1100 -> '╗'; 0b1001 -> '╔';
  0b0111 -> '╩'; 0b1110 -> '╣'; 0b1101 -> '╦'; 0b1011 -> '╠';
  0b1111 -> '╬';
  s -> error $ "impossible! " ++ show s

-- * Outro

outroPart =
  vertCatMiddle
  [ multiLineText (defAttr `withBackColor` red) "\
    \            \n\
    \  GAVNOMER  \n\
    \            "
  , space
  , multiLineText defAttr "\
    \               \n\
    \  PRESS ENTER  \n\
    \    TO EXIT    \n\
    \               "
  ] 

-- * Miscellanous

space = resize 1 1 emptyImage

waitForAnyKey :: (?events :: TQueue Event) => IO Key
waitForAnyKey = atomically $ fix \redo -> readTQueue ?events >>= \case
  EvKey k [] -> return k
  _ -> redo

waitFor key = fix \redo -> waitForAnyKey >>= \key' ->
  if key == key' then return () else redo

for = flip map

ifBomb item f = case item of
  Bomb -> f
  _ -> id

multiLineText attr = vertCat . map (text' attr) . T.lines . T.pack

